home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / tpb4_src.zip / SYSOP1.PAS < prev    next >
Pascal/Delphi Source File  |  1988-09-13  |  9KB  |  303 lines
  1. { TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen  
  2.   Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault  
  3.   
  4.   Last modified  ::  6-12-88 3:58 pm 
  5. }
  6.  
  7. {$R-}                             {Range checking off}
  8. {$B-}                             {Boolean complete evaluation off}
  9. {$S-}                             {Stack checking off}
  10. {$I+}                             {I/O checking on}
  11. {$N-}                             {No numeric coprocessor}
  12.  
  13. Unit Sysop1;
  14.  
  15. Interface
  16.  
  17. Uses
  18.   TPCrt, Dos, Globals, TAccess, Core1, Misc,
  19.   Core2, TPSTRING, Dirs, MsgMove, MsgRead;
  20.   
  21.   
  22. procedure hide_release(name            : DosFileName;
  23.                        status          : record_status;
  24.                        Dirspec         : StrPr);
  25.                        
  26. function get_section_name(mode : Char)    : DosFileName;
  27.  
  28. procedure rebuild_index;
  29.  
  30. procedure toggle_printer;
  31.  
  32. procedure print_messages;
  33.  
  34.  
  35.   {==========================================================================}
  36.   
  37.   
  38. Implementation
  39.  
  40.  
  41.   procedure hide_release(name            : DosFileName;
  42.                          status          : record_status;
  43.                          Dirspec         : StrPr);
  44.     { Hide or release file }
  45.     
  46.   var
  47.     attributes      : Word;
  48.     
  49.   begin
  50.     SetSect(Dirspec);
  51.     Assign(temp_file, name);
  52.     if status = public then
  53.       attributes := 0             {make visable}
  54.     else
  55.       attributes := Hidden+SysFile; {set System and Hidden bits}
  56.     SetFAttr(temp_file, attributes);
  57.     
  58.     if (user_rec.access >= 250) or (not remote_copy) then
  59.       begin
  60.         if DosError = 2 then
  61.           WriteLn(Com, name, ' not found.');
  62.         if DosError = 3 then
  63.           WriteLn(Com, 'path: ', Dirspec, ' not found.');
  64.         if DosError = 5 then
  65.           WriteLn(Com, 'Access denied by DOS.');
  66.       end;
  67.   end;
  68.   
  69.   
  70.   
  71.   function get_section_name(mode : Char)    : DosFileName;
  72.     { for file area sections}
  73.     
  74.   var
  75.     This            : SectPtr;
  76.     line_count,
  77.     conf_num        : Integer;
  78.     work            : DosFileName;
  79.     
  80.   begin
  81.     abort := False;
  82.     repeat
  83.       This := SectBase;
  84.       WriteLn(Com);
  85.       work := prompt('Section name ', 12, 'ES?M');
  86.       if (work = ' ') and (mode <> 'L') then
  87.         begin
  88.           work := SectReq;        { default to current value }
  89.           WriteLn(Com, 'Defaulting to: ', SectReq);
  90.         end;
  91.       if work = '?' then
  92.         begin
  93.           line_count := 2;
  94.           WriteLn(Com, 'Available file areas:');
  95.           WriteLn(Com);
  96.           while (not brk) and (This <> nil) do
  97.             begin
  98.               conf_num := This^.SectConf;
  99.               if (user_rec.access >= This^.SectAccs) or (test_bit(user_rec.conf_flags,
  100.                 conf_num)) then
  101.                 begin
  102.                   Write(Com, pad(This^.SectName, 14));
  103.                   if (mode = 'D') or (mode = 'L') then
  104.                     WriteLn(Com, This^.SectDesc)
  105.                   else
  106.                     WriteLn(Com);
  107.                 end;
  108.               This := This^.next;
  109.               if user_rec.lines <> 99 then
  110.                 begin
  111.                   Inc(line_count);
  112.                   if line_count mod user_rec.lines = 0 then
  113.                     pause;
  114.                 end;
  115.             end;
  116.           WriteLn(Com);
  117.         end;
  118.       This := SectBase;
  119.       while (This <> nil) and (This^.SectName <> work) do
  120.         This := This^.next;
  121.     until (work = This^.SectName) or (brk) or (not Online);
  122.     if work = This^.SectName then
  123.       get_section_name := work
  124.     else
  125.       get_section_name := '';
  126.   end;
  127.   
  128.   
  129.   
  130.   procedure rebuild_index;
  131. { Rebuild the user index file from the data file.  In addition, this routine
  132.   will recover the data file from certain types of damage. }
  133.   
  134.   var
  135.     previous_rec,
  136.     count_used,
  137.     count_unused    : Integer;
  138.     i               : LongInt;
  139.     key             : StrName;
  140.     temp_user_rec   : user_list;
  141.     temp            : file;
  142.     
  143.   begin
  144.     SetSect(HomName);
  145.     WriteLn(Com, 'Rebuilding user index file.');
  146.     WriteLn(Com, 'User data file in record order:');
  147.     CloseIndex(IdxF);
  148.     Assign(temp, user_indx+ext);
  149.     Erase(temp);
  150.     MakeIndex(IdxF, user_indx+ext, len_ln+len_fn, 0);
  151.     previous_rec := -1;
  152.     count_used := 0;
  153.     count_unused := 0;
  154.     with temp_user_rec do
  155.       begin
  156.         for i := 1 to Pred(FileLen(DatF)) do
  157.           begin
  158.             GetRec(DatF, i, temp_user_rec);
  159.             if used = 0 then
  160.               begin
  161.                 key := pad(ln, len_ln)+pad(fn, len_fn);
  162.                 AddKey(IdxF, i, key);
  163.                 if OK then
  164.                   begin
  165.                     Inc(count_used);
  166.                     WriteLn(Com, i:4, '  ', used:4, '  ', fn, ' ', ln)
  167.                   end
  168.                 else
  169.                   begin
  170.                     used := previous_rec; { Can't use DeleteRec since }
  171.                     previous_rec := i; { we're playing with pointers }
  172.                     PutRec(DatF, i, temp_user_rec);
  173.                     Inc(count_unused);
  174.                     WriteLn(Com, i:4, '  ', used:4, '  Duplicate record deleted')
  175.                   end
  176.               end
  177.             else
  178.               begin
  179.                 used := previous_rec;
  180.                 previous_rec := i;
  181.                 PutRec(DatF, i, temp_user_rec);
  182.                 Inc(count_unused);
  183.                 WriteLn(Com, i:4, '  ', used:4, '  Free record')
  184.               end
  185.           end
  186.       end;
  187.       
  188.     GetRec(DatF, 0, temp_user_rec);
  189.     DatF.FirstFree := previous_rec;
  190.     DatF.NumberFree := count_unused;
  191.     PutRec(DatF, 0, temp_user_rec);
  192.     FlushFile(DatF);
  193.     FlushIndex(IdxF);
  194.     WriteLn(Com);
  195.     WriteLn(Com, FileLen(DatF), ' records, ', UsedRecs(DatF), ' users in file.')
  196.   end;
  197.   
  198.   
  199.   
  200.   procedure toggle_printer;
  201.     { Turn printer on and off }
  202.     
  203.   begin
  204.     if printer_copy then
  205.       printer_copy := False
  206.     else
  207.       printer_copy := ask('Turn on printer', 'N');
  208.     Write(Com, 'Printer o');
  209.     if printer_copy then
  210.       WriteLn(Com, 'n.')
  211.     else
  212.       WriteLn(Com, 'ff.')
  213.   end;
  214.   
  215.   
  216.   
  217.   procedure print_messages;
  218.     { Print the message file }
  219.     
  220.   var
  221.     i, j,
  222.     first_line,
  223.     last_line       : Integer;
  224.     cur_date        : Real;
  225.     Fr_fn           : FirstName;
  226.     Fr_ln           : LastName;
  227.     t               : tad_array;
  228.     Str             : StrTAD;
  229.     err             : Boolean;
  230.     
  231.   begin
  232.     abort := False;
  233.     Str := prompt('Date to start listing [mm/dd/yy]', 8, 'E');
  234.     if ch <> ETX then
  235.       begin
  236.         GetTAD(t);
  237.         if Length(Str) >= 2 then
  238.           t[4] := strint(Copy(Str, 1, 2)); {month}
  239.         if Length(Str) >= 5 then
  240.           t[3] := strint(Copy(Str, 4, 2)); {day}
  241.         if Length(Str) >= 8 then
  242.           t[5] := strint(Copy(Str, 7, 2)); {year}
  243.         cur_date := greg_to_jul(t[3], t[4], t[5]);
  244.         GetTAD(t);
  245.         Str := FormTAD(t);
  246.         WriteLn(Com, 'Message file as of: ', Str);
  247.         if audit_on then
  248.           begin
  249.             SetSect(AudName);
  250.             WriteLn(AuditFile, FF, 'Message file as of: ', Str);
  251.             SetSect(HomName);
  252.           end;
  253.         i := 1;
  254.         {$I-}
  255.         Seek(summ_file, 1); {$I+}
  256.         err := (IoResult <> 0);
  257.         while (not err) and (not brk) and Online and (not EoF(summ_file)) do
  258.           begin
  259.             {$I-}
  260.             Read(summ_file, summ_rec) {$I+} ;
  261.             err := (IoResult <> 0);
  262.             if (not err) and (greg_to_jul(summ_rec.date[3], summ_rec.date[4], summ_rec.date[5]
  263.               ) >= cur_date) then
  264.               begin
  265.                 WriteLn(Com);
  266.                 if audit_on then
  267.                   begin
  268.                     SetSect(AudName);
  269.                     WriteLn(AuditFile);
  270.                     SetSect(HomName);
  271.                   end;
  272.                 mesg_header_list(i, first_line, last_line, Fr_fn, Fr_ln);
  273.                 {$I-}
  274.                 Seek(mesg_file, first_line); {$I+}
  275.                 err := (IoResult <> 0);
  276.                 if (not err) then
  277.                   begin
  278.                     for J := 1 to last_line do
  279.                       begin
  280.                         {$I-}
  281.                         Read(mesg_file, mesg_rec); {$I+}
  282.                         err := (IoResult <> 0);
  283.                         if (not err) then
  284.                           WriteLn(Com, mesg_rec);
  285.                         if audit_on and (not err) then
  286.                           begin
  287.                             SetSect(AudName);
  288.                             WriteLn(AuditFile, mesg_rec);
  289.                             SetSect(HomName);
  290.                           end;
  291.                       end;
  292.                   end;
  293.               end;
  294.             Inc(i);
  295.           end;
  296.       end;
  297.   end;
  298.   
  299.   
  300. end.                              { of SYSOP1.PAS}
  301.  
  302. 
  303.